
exception Error
exception Unknown_identifier of string

type const_t =
    Nil
  | Unit
  | Int of int
  | Bool of bool
  | String of string

type unop_t =
    Not
  | ToString
  | Write
  | Fail
  | First | Second
  | Head | Tail
  | Ref | Deref

type binop_t =
    Pair
  | Cons
  | Concat
  | Plus | Minus | Times | Divide
  | And | Or
  | Eq | Ne | Le | Lt
  | Assign
    
type t =
    Const of const_t
  | Id of string
  | Fun of string * t
  | Apply of t * t
  | UnaryOp of unop_t * t
  | BinaryOp of binop_t * t * t
  | Let of string * t * t
  | LetRec of string * t * t
  | If of t * t * t

let compile_const =
  function
      Nil
    | Unit -> Secd.Bool false
    | Int n -> Secd.Int n
    | Bool b -> Secd.Bool b
    | String s -> Secd.String s

let compile_unary_op =
  function
      Not -> Secd.NOT
    | ToString -> Secd.STRING
    | Write -> Secd.WRITE
    | Fail -> Secd.FAIL
    | First | Head -> Secd.FST
    | Second | Tail -> Secd.SND
    | Ref -> Secd.REF
    | Deref -> Secd.DEREF

let compile_binary_op =
  function
      Pair
    | Cons -> Secd.PAIR
    | Concat -> Secd.CONCAT
    | Plus -> Secd.ADD
    | Minus -> Secd.SUB
    | Times -> Secd.MUL
    | Divide -> Secd.DIV
    | And -> Secd.AND
    | Or -> Secd.OR
    | Eq -> Secd.EQ
    | Ne -> Secd.NE
    | Le -> Secd.LE
    | Lt -> Secd.LT
    | Assign -> Secd.ASSIGN

let rec fetch x =
  function
      [] -> raise (Unknown_identifier x)
    | v::_ when x = v -> 1
    | _::l' -> 1 + (fetch x l')

let rec compile nl =
  function
      Const k -> [Secd.LDC (compile_const k)]
    | Id x -> [Secd.LD (fetch x nl)]
    | UnaryOp(op,t) -> List.append (compile nl t) [compile_unary_op op]
    | BinaryOp(op,t1,t2) -> List.append (compile nl t1) (List.append (compile nl t2) [compile_binary_op op])
    | Fun(x,t) -> [Secd.FUN (compile (x::nl) t)]
    | Apply(t1,t2) -> List.append (compile nl t2) (List.append (compile nl t1) [Secd.APP])
    | Let(x,t1,t2) -> compile nl (Apply(Fun(x,t2),t1))
    | LetRec(x,Fun(y,t1),t2) -> [Secd.FUN(compile (y::x::nl) t1); Secd.REC; Secd.FUN(compile (x::nl) t2); Secd.APP]
    | LetRec(_,_,_) -> raise Error
    | If(t1,t2,t3) -> List.append (compile nl t1) [Secd.SEL((compile nl t2), (compile nl t3))]

